home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlseq.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  26.4 KB  |  1,293 lines
  1. /* xlseq.c - xlisp sequence functions */
  2. /*    Written by Thomas Almy, based on code:
  3.     Copyright (c) 1985, by David Michael Betz
  4.     All Rights Reserved
  5.     Permission is granted for unrestricted non-commercial use    */
  6.  
  7. #include "xlisp.h"
  8. #include <string.h>
  9.  
  10. #ifdef COMMONLISP
  11.  
  12. /* external variables */
  13. extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
  14. extern LVAL true;
  15.  
  16. /* this is part of the COMMON LISP extension: */
  17. /* (elt seq index)  -- generic sequence reference function */
  18. /* (map type fcn seq1 [seq2 ...]) -- generic sequence mapping function */
  19. /*   type is one of cons, array, string, or nil */
  20. /* (some fcn seq1 [seq2 ...]) -- apply fcn until non-nil */
  21. /*    also every notany and notevery */
  22. /* (concatenate type seq1 [seq2 ...]) -- sequence concatenation function */
  23. /*    type is one of cons, array, or string. */
  24. /* (position-if pred seq) -- returns position of first match */
  25. /* (search seq1 seq1 &key :test :test-not :start1 :end1 :start2 :end2) --
  26.     generic sequence searching function. */
  27. /* subseq reverse remove remove-if remove-if-not delete delete-if 
  28.    delete-if-not -- rewritten to allow all sequence types */
  29. /* find-if count-if -- previous Common Lisp extension, rewritten to allow
  30.    all sequence types */
  31. /* the keyword arguments :start and :end are now valid for the remove, delete,
  32.    find position and count functions */
  33.  
  34.  
  35. /* The author, Tom Almy, appologizes for using "goto" several places in
  36.    this code. */
  37.  
  38. #define MAXSIZE ((unsigned)-1)    /* the maximum unsigned integer value */
  39.  
  40. #ifdef ANSI
  41. static void getseqbounds(unsigned *start, unsigned *end, unsigned length, 
  42.                          LVAL *startkey, LVAL *endkey)
  43. #else
  44. LOCAL VOID getseqbounds(start,end,length,startkey,endkey)
  45. unsigned *start, *end, length;
  46. LVAL *startkey, *endkey;
  47. #endif
  48. {
  49.     LVAL arg;
  50.     FIXTYPE temp;
  51.  
  52.     if (xlgkfixnum(*startkey,&arg)) {
  53.         temp = (long)getfixnum(arg);
  54.         if (temp < 0 || temp > length ) goto rangeError;
  55.         *start = (unsigned)temp;
  56.     }
  57.     else *start = 0;
  58.     
  59.     if (xlgetkeyarg(*endkey, &arg) && arg != NIL) {
  60.         if (!fixp(arg)) xlbadtype(arg);
  61.         temp = (long)getfixnum(arg);
  62.         if (temp < *start  || temp > length) goto rangeError;
  63.         *end = (unsigned)temp;    
  64.     }
  65.     else *end = length;
  66.     
  67.     return;
  68.     /* else there is a range error */
  69.     
  70. rangeError:
  71.     xlerror("range error",arg);
  72. }
  73.         
  74.  
  75.  
  76. /* dotest1 - call a test function with one argument */
  77. /* this function was in xllist.c */
  78. #ifdef ANSI
  79. static int dotest1(LVAL arg, LVAL fun)
  80. #else
  81. LOCAL int dotest1(arg,fun)
  82.   LVAL arg,fun;
  83. #endif
  84. {
  85.     LVAL *newfp;
  86.  
  87.     /* create the new call frame */
  88.     newfp = xlsp;
  89.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  90.     pusharg(fun);
  91.     pusharg(cvfixnum((FIXTYPE)1));
  92.     pusharg(arg);
  93.     xlfp = newfp;
  94.  
  95.     /* return the result of applying the test function */
  96.     return (xlapply(1) != NIL);
  97.  
  98. }
  99.  
  100.  
  101. /* xelt - sequence reference function */
  102. LVAL xelt()
  103. {
  104.     LVAL seq,index;
  105.     FIXTYPE i;
  106.     
  107.     /* get the sequence and the index */
  108.  
  109.     seq = xlgetarg();
  110.  
  111.     index = xlgafixnum(); i = getfixnum(index);    
  112.     if (i < 0) goto badindex;
  113.     
  114.     xllastarg();
  115.  
  116.     if (listp(seq)) { /* do like nth, but check for in range */
  117.         /* find the ith element */
  118.         while (consp(seq)) {
  119.             if (i-- == 0) return (car(seq));
  120.             seq = cdr(seq);
  121.         }
  122.         goto badindex;    /* end of list reached first */
  123.     }
  124.         
  125.  
  126.     if (ntype(seq) == STRING) {    
  127.         if (i >= getslength(seq)-1) goto badindex;
  128.         return (cvchar(getstringch(seq,i)));
  129.     }
  130.     
  131.     if (ntype(seq)!=VECTOR) xlbadtype(seq);    /* type must be array */
  132.  
  133.     /* range check the index */
  134.     if (i >= getsize(seq)) goto badindex;
  135.  
  136.     /* return the array element */
  137.     return (getelement(seq,(int)i));
  138.     
  139. badindex:
  140.     xlerror("index out of bounds",index);
  141.     return (NIL);    /* eliminate warnings */
  142. }
  143.  
  144.  
  145. /* xmap -- map function */
  146.  
  147. #ifdef ANSI
  148. static unsigned getlength(LVAL seq)
  149. #else
  150. LOCAL unsigned getlength(seq)
  151. LVAL seq;
  152. #endif
  153. {
  154.     unsigned len;
  155.     
  156.     if (seq == NIL) return 0;
  157.     
  158.     switch (ntype(seq)) {
  159.         case STRING: 
  160.             return (unsigned)(getslength(seq) - 1);
  161.         case VECTOR: 
  162.             return (unsigned)(getsize(seq));
  163.         case CONS: 
  164.             len = 0;
  165.             while (consp(seq)) {
  166.                 len++;
  167.                 seq = cdr(seq);
  168.             }
  169.             return len;
  170.         default: 
  171.             xlbadtype(seq);
  172.             return (0); /* ha ha */
  173.         }
  174. }
  175.  
  176.  
  177. LVAL xmap()
  178. {
  179.     LVAL *newfp, fun, lists, val, last, x, y;
  180.     unsigned len,temp, i;
  181.     int argc, typ;
  182.     
  183.     /* protect some pointers */
  184.     xlstkcheck(3);
  185.     xlsave(fun);
  186.     xlsave(lists);
  187.     xlsave(val);
  188.  
  189.     /* get the type of resultant */
  190.     if ((last = xlgetarg()) == NIL) {    /* nothing is returned */
  191.         typ = 0;
  192.     }
  193.     else if ((typ = xlcvttype(last)) != CONS && 
  194.                 typ != STRING && typ != VECTOR) {
  195.         xlerror("invalid result type", last);
  196.     }
  197.     
  198.     /* get the function to apply and argument sequences */
  199.     fun = xlgetarg();
  200.     val = NIL;
  201.     lists = xlgetarg();
  202.     len = getlength(lists);
  203.     argc = 1;
  204.  
  205.     /* check for invalid result size (actually only needed when 16bit ints)*/
  206.     if (((int)len)<0 && (typ==STRING || typ==VECTOR)) {
  207.         xlerror("too long",last);
  208.     }
  209.  
  210.     /* build a list of argument lists */
  211.     for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
  212.         val = xlgetarg();
  213.         if ((temp = getlength(val)) < len) len = temp;
  214.         argc++;
  215.         rplacd(last,(cons(val,NIL)));
  216.     }
  217.     
  218.     /* initialize the result list */
  219.     switch (typ) {
  220.         case VECTOR: val = newvector(len); break;
  221.         case STRING: val = newstring(len+1); break;
  222.         default:    val = NIL; break;
  223.     }
  224.     
  225.     
  226.     /* loop through each of the argument lists */
  227.     for (i=0;i<len;i++) {
  228.  
  229.         /* build an argument list from the sublists */
  230.         newfp = xlsp;
  231.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  232.         pusharg(fun);
  233.         pusharg(NIL);
  234.         for (x = lists; x != NIL ; x = cdr(x)) {
  235.             y = car(x);
  236.             switch (ntype(y)) {
  237.                 case CONS: 
  238.                     pusharg(car(y));
  239.                     rplaca(x,cdr(y));
  240.                     break;
  241.                 case VECTOR:
  242.                     pusharg(getelement(y,i));
  243.                     break;
  244.                 case STRING:
  245.                     pusharg(cvchar(getstringch(y,i)));
  246.                     break;
  247.             }
  248.         }
  249.  
  250.         /* apply the function to the arguments */
  251.         newfp[2] = cvfixnum((FIXTYPE)argc);
  252.         xlfp = newfp;
  253.         x = xlapply(argc);
  254.         
  255.         switch (typ) {
  256.             case CONS:
  257.                 y = consa(x);
  258.                 if (val) rplacd(last,y);
  259.                 else val = y;
  260.                 last = y;
  261.                 break;
  262.             case VECTOR:
  263.                 setelement(val,i,x);
  264.                 break;
  265.             case STRING:
  266.                 if (!charp(x)) 
  267.                     xlerror("map function returned non-character",x);
  268.                 val->n_string[i] = getchcode(x);
  269.                 break;
  270.         }
  271.             
  272.     }
  273.  
  274.     /* restore the stack */
  275.     xlpopn(3);
  276.  
  277.     /* return the last test expression value */
  278.     return (val);
  279.     }
  280.  
  281.  
  282. /* every, some, notany, notevery */
  283.  
  284. #define EVERY 0
  285. #define SOME 1
  286. #define NOTEVERY 2
  287. #define NOTANY 3
  288.  
  289. #ifdef ANSI
  290. static LVAL xlmapwhile(int cond)
  291. #else
  292. LOCAL LVAL xlmapwhile(cond)
  293. int cond;
  294. #endif
  295. {
  296.     int exitcond;
  297.     LVAL *newfp, fun, lists, val, last, x, y;
  298.     unsigned len,temp,i;
  299.     int argc;
  300.     
  301.     /* protect some pointers */
  302.     xlstkcheck(2);
  303.     xlsave(fun);
  304.     xlsave(lists);
  305.  
  306.     /* get the function to apply and argument sequences */
  307.     fun = xlgetarg();
  308.     lists = xlgetarg();
  309.     len = getlength(lists);
  310.     argc = 1;
  311.  
  312.     /* build a list of argument lists */
  313.     for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
  314.         val = xlgetarg();
  315.         if ((temp = getlength(val)) < len) len = temp;
  316.         argc++;
  317.         rplacd(last,(cons(val,NIL)));
  318.     }
  319.     
  320.     switch (cond) {
  321.         case SOME:
  322.         case NOTANY:
  323.             exitcond = TRUE;
  324.             val = NIL;
  325.             break;
  326.         case EVERY:
  327.         case NOTEVERY:
  328.             exitcond = FALSE;
  329.             val = true;
  330.             break;
  331.     }
  332.  
  333.  
  334.     /* loop through each of the argument lists */
  335.     for (i=0;i<len;i++) {
  336.  
  337.         /* build an argument list from the sublists */
  338.         newfp = xlsp;
  339.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  340.         pusharg(fun);
  341.         pusharg(NIL);
  342.         for (x = lists; x != NIL ; x = cdr(x)) {
  343.             y = car(x);
  344.             switch (ntype(y)) {
  345.                 case CONS: 
  346.                     pusharg(car(y));
  347.                     rplaca(x,cdr(y));
  348.                     break;
  349.                 case VECTOR:
  350.                     pusharg(getelement(y,i));
  351.                     break;
  352.                 case STRING:
  353.                     pusharg(cvchar(getstringch(y,i)));
  354.                     break;
  355.             }
  356.         }
  357.  
  358.         /* apply the function to the arguments */
  359.         newfp[2] = cvfixnum((FIXTYPE)argc);
  360.         xlfp = newfp;
  361.         val = xlapply(argc);
  362.         if ((val == NIL) ^ exitcond) break;
  363.     }
  364.  
  365.     if ((cond == NOTANY) | (cond == NOTEVERY)) {
  366.         if (val == NIL)  
  367.             val = true;
  368.         else 
  369.             val = NIL;
  370.     }
  371.     
  372.  
  373.     /* restore the stack */
  374.     xlpopn(2);
  375.  
  376.     /* return the last test expression value */
  377.     return (val);
  378.     }
  379.  
  380.  
  381. LVAL xevery()
  382. {
  383.     return xlmapwhile(EVERY);
  384. }
  385.  
  386. LVAL xsome()
  387. {
  388.     return xlmapwhile(SOME);
  389. }
  390.  
  391. LVAL xnotany()
  392. {
  393.     return xlmapwhile(NOTANY);
  394. }
  395.  
  396. LVAL xnotevery()
  397. {
  398.     return xlmapwhile(NOTEVERY);
  399. }
  400.  
  401. /* xconcatenate - concatenate a bunch of sequences */
  402. /* replaces (and extends) strcat, now a macro */
  403. #ifdef ANSI
  404. static int calclength(void)
  405. #else
  406. LOCAL int calclength()
  407. #endif
  408. {
  409.     LVAL tmp, *saveargv;
  410.     int saveargc;
  411.     int len;
  412.  
  413.     /* save the argument list */
  414.     saveargv = xlargv;
  415.     saveargc = xlargc;
  416.  
  417.     /* find the length of the new string or vector */
  418.     for (len = 0; moreargs(); ) {
  419.         tmp = xlgetarg();
  420.         len += getlength(tmp);
  421.  
  422.         if (len < 0) xlerror("too long",tmp);  /*trick to check for overflow*/
  423.     }
  424.  
  425.     /* restore the argument list */
  426.     xlargv = saveargv;
  427.     xlargc = saveargc;
  428.  
  429.     return len;
  430. }
  431.  
  432.  
  433. #ifdef ANSI
  434. static LVAL cattostring(void)
  435. #else
  436. LOCAL LVAL cattostring()
  437. #endif
  438. {
  439.     LVAL tmp,temp,val;
  440.     char *str;
  441.     int len,i;
  442.     
  443.     /* find resulting length -- also validates argument types */
  444.     len = calclength();
  445.  
  446.     /* create the result string */
  447.     val = newstring(len+1);
  448.     str = getstring(val);
  449.  
  450.     /* combine the strings */
  451.     while (moreargs()) {
  452.         tmp = nextarg();
  453.         if (tmp != NIL) switch (ntype(tmp)) {
  454.             case STRING: 
  455.                 len = getslength(tmp)-1;
  456.                 memcpy((char *)str, (char *)getstring(tmp), len);
  457.                 str += len;
  458.                 break;
  459.             case VECTOR:
  460.                 len = getsize(tmp);
  461.                 for (i = 0; i < len; i++) {
  462.                     temp = getelement(tmp,i);
  463.                     if (!charp(temp)) goto failed;
  464.                     *str++ = getchcode(temp);
  465.                 }
  466.                 break;
  467.             case CONS:
  468.                 while (consp(tmp)) {
  469.                     temp = car(tmp);
  470.                     if (!charp(temp)) goto failed;
  471.                     *str++ = getchcode(temp);
  472.                     tmp = cdr(tmp);
  473.                 }
  474.                 break;
  475.         }
  476.     }
  477.  
  478.     *str = 0;    /* delimit string (why, I don't know!) */
  479.  
  480.     /* return the new string */
  481.     return (val);
  482.  
  483. failed:
  484.     xlerror("cannot make into string", tmp);
  485.     return (NIL);    /* avoid warning message */
  486. }
  487.  
  488. #ifdef ANSI
  489. static LVAL cattovector(void)
  490. #else
  491. LOCAL LVAL cattovector()
  492. #endif
  493. {
  494.     LVAL tmp,val;
  495.     LVAL *vect;
  496.     int len,i;
  497.     
  498.     /* find resulting length -- also validates argument types */
  499.     len = calclength();
  500.  
  501.     /* create the result vector */
  502.     val = newvector(len);
  503.     vect = &val->n_vdata[0];
  504.  
  505.     /* combine the vectors */
  506.     while (moreargs()) {
  507.         tmp = nextarg();
  508.         if (tmp != NIL) switch (ntype(tmp)) {
  509.             case VECTOR: 
  510.                 len = getsize(tmp);
  511.                 memcpy(vect, &getelement(tmp,0), len*sizeof(LVAL));
  512.                 vect += len;
  513.                 break;
  514.             case STRING:
  515.                 len = getslength(tmp)-1;
  516.                 for (i = 0; i < len; i++) {
  517.                     *vect++ = cvchar(getstringch(tmp,i));
  518.                 }
  519.                 break;
  520.             case CONS:
  521.                 while (consp(tmp)) {
  522.                     *vect++ = car(tmp);
  523.                     tmp = cdr(tmp);
  524.                 }
  525.                 break;
  526.         }
  527.     }
  528.  
  529.     /* return the new vector */
  530.     return (val);
  531. }
  532.  
  533. #ifdef ANSI
  534. static LVAL cattocons(void)
  535. #else
  536. LOCAL LVAL cattocons()
  537. #endif
  538. {
  539.     LVAL val,tmp,next,last=NIL;
  540.     int len,i;
  541.     
  542.     xlsave1(val);        /* protect against GC */
  543.     
  544.     /* combine the lists */
  545.     while (moreargs()) {
  546.         tmp = nextarg();
  547.         if (tmp != NIL) switch (ntype(tmp)) {
  548.             case CONS:
  549.                 while (consp(tmp)) {
  550.                     next = consa(car(tmp));
  551.                     if (val) rplacd(last,next);
  552.                     else val = next;
  553.                     last = next;
  554.                     tmp = cdr(tmp);
  555.                 }
  556.                 break;
  557.             case VECTOR:
  558.                 len = getsize(tmp);
  559.                 for (i = 0; i<len; i++) {
  560.                     next = consa(getelement(tmp,i));
  561.                     if (val) rplacd(last,next);
  562.                     else val = next;
  563.                     last = next;
  564.                 }
  565.                 break;
  566.             case STRING:
  567.                 len = getslength(tmp) - 1;
  568.                 for (i = 0; i < len; i++) {
  569.                     next = consa(cvchar(getstringch(tmp,i)));
  570.                     if (val) rplacd(last,next);
  571.                     else val = next;
  572.                     last = next;
  573.                 }
  574.                 break;
  575.             default: 
  576.                 xlbadtype(tmp); break; /* need default because no precheck*/
  577.         }
  578.     }
  579.     
  580.     xlpop();
  581.     
  582.     return (val);
  583.  
  584. }
  585.     
  586.  
  587. LVAL xconcatenate()
  588. {
  589.     LVAL tmp;
  590.     
  591.     switch (xlcvttype(tmp = xlgetarg())) {    /* target type of data */
  592.         case CONS:        return cattocons();
  593.         case STRING:    return cattostring();            
  594.         case VECTOR:    return cattovector();
  595.         default:        xlerror("invalid result type", tmp);
  596.                         return (NIL);    /* avoid warning */
  597.     }
  598. }
  599.  
  600. /* xsubseq - return a subsequence -- new version */
  601.  
  602. LVAL xsubseq()
  603. {
  604.     unsigned start,end,len;
  605.     FIXTYPE temp;
  606.     int srctype;
  607.     LVAL src,dst;
  608.     LVAL next,last=NIL;
  609.  
  610.     /* get sequence */
  611.     src = xlgetarg();
  612.     if (listp(src)) srctype = CONS;
  613.     else srctype=ntype(src);
  614.  
  615.     
  616.     /* get length */
  617.     switch (srctype) {
  618.         case STRING:
  619.             len = getslength(src) - 1;
  620.             break;
  621.         case VECTOR:
  622.             len = getsize(src);
  623.             break;
  624.         case CONS:
  625.             dst = src;    /* use dst as temporary */
  626.             len = 0;
  627.             while (consp(dst)) {len++; dst = cdr(dst);}
  628.             break;
  629.         default:
  630.             xlbadtype(src);
  631.     }
  632.  
  633.     /* get the starting position */
  634.     dst = xlgafixnum(); temp = (int)getfixnum(dst);
  635.     if (temp < 0 || temp > len) 
  636.         xlerror("sequence index out of bounds",dst);
  637.     start = (unsigned) temp;
  638.  
  639.     /* get the ending position */
  640.     if (moreargs()) {
  641.         dst = nextarg();
  642.         if (dst == NIL) end = len;
  643.         else if (fixp(dst)) {
  644.             temp = (int)getfixnum(dst);
  645.             if (temp < start || temp > len)
  646.                 xlerror("sequence index out of bounds",dst);
  647.             end = (unsigned) temp;
  648.         }
  649.         else xlbadtype(dst);
  650.     }
  651.     else
  652.         end = len;
  653.     xllastarg();
  654.  
  655.     len = end - start;
  656.     
  657.     switch (srctype) {    /* do the subsequencing */
  658.         case STRING:
  659.             dst = newstring(len+1);
  660.             memcpy(getstring(dst), getstring(src)+start, len);
  661.             dst->n_string[len] = 0;
  662.             break;
  663.         case VECTOR:
  664.             dst = newvector(len);
  665.             memcpy(dst->n_vdata, &src->n_vdata[start], sizeof(LVAL)*len);
  666.             break;
  667.         case CONS:
  668.             xlsave1(dst);
  669.             while (start--) src = cdr(src);
  670.             while (len--) {
  671.                 next = consa(car(src));
  672.                 if (dst) rplacd(last,next);
  673.                 else dst = next;
  674.                 last = next;
  675.                 src = cdr(src);
  676.             }
  677.             xlpop();
  678.             break;
  679.     }
  680.  
  681.     /* return the substring */
  682.     return (dst);
  683. }
  684.  
  685.  
  686. /* xnreverse -- built-in function nreverse (destructive reverse) */
  687. LVAL xnreverse()
  688. {
  689.     LVAL seq,val,next;
  690.     unsigned int i,j;
  691.     int ival;
  692.  
  693.     /* get the sequence to reverse */
  694.     seq = xlgetarg();
  695.     xllastarg();
  696.  
  697.     if (seq == NIL) return (NIL);    /* empty argument */
  698.     
  699.     switch (ntype(seq)) {
  700.         case CONS:
  701.             val = NIL;
  702.             while (consp(seq)) {
  703.                 next = cdr(seq);
  704.                 rplacd(seq,val);
  705.                 val = seq;
  706.                 seq = next;
  707.             }
  708.             break;
  709.         case VECTOR:
  710.             for (i = 0, j = getlength(seq)-1; i < j; i++, j--) {
  711.                 val = getelement(seq,i);
  712.                 setelement(seq,i,getelement(seq,j));
  713.                 setelement(seq,j,val);
  714.             }
  715.             return seq;
  716.             break;
  717.         case STRING:
  718.             for (i = 0, j=getslength(seq)-2 ; i < j; i++, j--) {
  719.                 ival = seq->n_string[i];
  720.                 seq->n_string[i] = seq->n_string[j];
  721.                 seq->n_string[j] = ival;
  722.             }
  723.             return seq;
  724.             break;
  725.         default: 
  726.             xlbadtype(seq); break;
  727.     }
  728.  
  729.     /* return the sequence */
  730.     return (val);
  731. }
  732.  
  733. /* xreverse - built-in function reverse -- new version */
  734. LVAL xreverse()
  735. {
  736.     LVAL seq,val;
  737.     int i,len;
  738.  
  739.     /* get the sequence to reverse */
  740.     seq = xlgetarg();
  741.     xllastarg();
  742.  
  743.     if (seq == NIL) return (NIL);    /* empty argument */
  744.     
  745.     switch (ntype(seq)) {
  746.         case CONS:
  747.             /* protect pointer */
  748.             xlsave1(val);
  749.  
  750.             /* append each element to the head of the result list */
  751.             for (val = NIL; consp(seq); seq = cdr(seq))
  752.                 val = cons(car(seq),val);
  753.  
  754.             /* restore the stack */
  755.             xlpop();
  756.             break;
  757.         case VECTOR:
  758.             len = getsize(seq);
  759.             val = newvector(len);
  760.             for (i = 0; i < len; i++)
  761.                 setelement(val,i,getelement(seq,len-i-1));
  762.             break;
  763.         case STRING:
  764.             len = getslength(seq) - 1;
  765.             val = newstring(len+1);
  766.             for (i = 0; i < len; i++)
  767.                 val->n_string[i] = seq->n_string[len-i-1];
  768.             val->n_string[len] = 0;
  769.             break;
  770.         default: 
  771.             xlbadtype(seq); break;
  772.     }
  773.  
  774.     /* return the sequence */
  775.     return (val);
  776. }
  777.  
  778.  
  779. /* remif - common code for 'remove', 'remove-if', and 'remove-if-not' */
  780. #ifdef ANSI
  781. static LVAL remif(int tresult, int expr)
  782. #else
  783. LOCAL LVAL remif(tresult,expr)
  784.   int tresult,expr;
  785. #endif
  786. {
  787.     LVAL x,seq,fcn,val,last,next;
  788.     unsigned i,j,l;
  789.     unsigned start,end;
  790.  
  791.     if (expr) {
  792.         /* get the expression to remove and the sequence */
  793.         x = xlgetarg();
  794.         seq = xlgetarg();
  795.         xltest(&fcn,&tresult);
  796.     }
  797.     else {
  798.         /* get the function and the sequence */
  799.         fcn = xlgetarg();
  800.         seq = xlgetarg();
  801. /*        xllastarg(); */
  802.     }
  803.  
  804.     if (seq == NIL) return NIL;
  805.  
  806.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  807.     
  808.     /* protect some pointers */
  809.     xlstkcheck(2);
  810.     xlprotect(fcn);
  811.     xlsave(val);
  812.  
  813.     /* remove matches */
  814.     
  815.     switch (ntype(seq)) {
  816.         case CONS:
  817.             for (; consp(seq); seq = cdr(seq)) {
  818.                 long s=start, l=end-start;
  819.                 /* check to see if this element should be deleted */
  820.                 /* force copy if count, as specified by end, is exhausted */
  821.                 if (s-- > 0 || l-- <= 0 || 
  822.                     (expr?dotest2(x,car(seq),fcn)
  823.                     :dotest1(car(seq),fcn)) != tresult) {
  824.                     next = consa(car(seq));
  825.                     if (val) rplacd(last,next);
  826.                     else val = next;
  827.                     last = next;
  828.                 }
  829.             }
  830.             break;
  831.         case VECTOR:
  832.             val = newvector(l=getlength(seq));
  833.             for (i=j=0; i < l; i++) {
  834.                 if (i < start || i >= end ||    /* copy if out of range */
  835.                     (expr?dotest2(x,getelement(seq,i),fcn)
  836.                     :dotest1(getelement(seq,i),fcn)) != tresult) {
  837.                     setelement(val,j++,getelement(seq,i));
  838.                 }
  839.             }
  840.             if (l != j) { /* need new, shorter result -- too bad */
  841.                 fcn = val; /* save value in protected cell */
  842.                 val = newvector(j);
  843.                 memcpy(val->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
  844.             }
  845.             break;
  846.         case STRING:
  847.             l = getslength(seq)-1;
  848.             val = newstring(l+1);
  849.             for (i=j=0; i < l; i++) {
  850.                 if (i < start || i >= end ||    /* copy if out of range */
  851.                     (expr?dotest2(x,cvchar(getstringch(seq,i)),fcn)
  852.                     :dotest1(cvchar(getstringch(seq,i)),fcn)) != tresult) {
  853.                     val->n_string[j++] = seq->n_string[i];
  854.                 }
  855.             }
  856.             if (l != j) { /* need new, shorter result -- too bad */
  857.                 fcn = val; /* save value in protected cell */
  858.                 val = newstring(j+1);
  859.                 memcpy(val->n_string, fcn->n_string, j*sizeof(char));
  860.                 val->n_string[j] = 0;
  861.             }
  862.             break;
  863.         default:
  864.             xlbadtype(seq); break;
  865.     }
  866.         
  867.             
  868.     /* restore the stack */
  869.     xlpopn(2);
  870.  
  871.     /* return the updated sequence */
  872.     return (val);
  873. }
  874.  
  875. /* xremif - built-in function 'remove-if' -- enhanced version */
  876. LVAL xremif()
  877. {
  878.     return (remif(TRUE,FALSE));
  879. }
  880.  
  881. /* xremifnot - built-in function 'remove-if-not' -- enhanced version */
  882. LVAL xremifnot()
  883. {
  884.     return (remif(FALSE,FALSE));
  885. }
  886.  
  887. /* xremove - built-in function 'remove' -- enhanced version */
  888.  
  889. LVAL xremove()
  890. {
  891.     return (remif(TRUE,TRUE));
  892. }
  893.  
  894.  
  895. /* delif - common code for 'delete', 'delete-if', and 'delete-if-not' */
  896. #ifdef ANSI
  897. static LVAL delif(int tresult, int expr)
  898. #else
  899. LOCAL LVAL delif(tresult,expr)
  900.   int tresult,expr;
  901. #endif
  902. {
  903.     LVAL x,seq,fcn,last,val;
  904.     unsigned i,j,l;
  905.     unsigned start,end;
  906.  
  907.     if (expr) {
  908.         /* get the expression to delete and the sequence */
  909.         x = xlgetarg();
  910.         seq = xlgetarg();
  911.         xltest(&fcn,&tresult);
  912.     }
  913.     else {
  914.         /* get the function and the sequence */
  915.         fcn = xlgetarg();
  916.         seq = xlgetarg();
  917. /*        xllastarg(); */
  918.     }
  919.  
  920.     if (seq == NIL) return NIL;
  921.  
  922.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  923.  
  924.     /* protect a pointer */
  925.     xlstkcheck(1);
  926.     xlprotect(fcn);
  927.  
  928.  
  929.     /* delete matches */
  930.     
  931.     switch (ntype(seq)) {
  932.         case CONS:
  933.             end -= start; /* gives length */
  934.             /* delete leading matches */
  935.             while (consp(seq)) {
  936.                 if (start-- > 0 || (expr?dotest2(x,car(seq),fcn)
  937.                     :dotest1(car(seq),fcn)) != tresult)
  938.                     break;
  939.                 seq = cdr(seq);
  940.             }
  941.             val = last = seq;
  942.  
  943.             /* delete embedded matches */
  944.             if (consp(seq)) {
  945.  
  946.                 /* skip the first non-matching element */
  947.                 seq = cdr(seq);
  948.  
  949.                 for (;consp(seq) && start-- > 0;seq=cdr(seq));
  950.  
  951.                 /* look for embedded matches */
  952.                 while (consp(seq)) {
  953.  
  954.                     /* check to see if this element should be deleted */
  955.                     if (end-- > 0 &&
  956.                         (expr?dotest2(x,car(seq),fcn)
  957.                     :dotest1(car(seq),fcn)) == tresult)
  958.                         rplacd(last,cdr(seq));
  959.                     else
  960.                         last = seq;
  961.  
  962.                     /* move to the next element */
  963.                     seq = cdr(seq);
  964.                 }
  965.             }
  966.             break;
  967.         case VECTOR:
  968.             l = getlength(seq);
  969.             for (i=j=0; i < l; i++) {
  970.                 if (i < start || i >= end ||    /* copy if out of range */
  971.                     (expr?dotest2(x,getelement(seq,i),fcn)
  972.                     :dotest1(getelement(seq,i),fcn)) != tresult) {
  973.                     if (i != j) setelement(seq,j,getelement(seq,i));
  974.                     j++;
  975.                 }
  976.             }
  977.             if (l != j) { /* need new, shorter result -- too bad */
  978.                 fcn = seq; /* save value in protected cell */
  979.                 seq = newvector(j);
  980.                 memcpy(seq->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
  981.             }
  982.             val = seq;
  983.             break;
  984.         case STRING:
  985.             l = getslength(seq)-1;
  986.             for (i=j=0; i < l; i++) {
  987.                 if (i < start || i >= end ||    /* copy if out of range */
  988.                     (expr?dotest2(x,cvchar(getstringch(seq,i)),fcn)
  989.                     :dotest1(cvchar(getstringch(seq,i)),fcn)) != tresult) {
  990.                     if (i != j) seq->n_string[j] = seq->n_string[i];
  991.                     j++;
  992.                 }
  993.             }
  994.             if (l != j) { /* need new, shorter result -- too bad */
  995.                 fcn = seq; /* save value in protected cell */
  996.                 seq = newstring(j+1);
  997.                 memcpy(seq->n_string, fcn->n_string, j*sizeof(char));
  998.                 seq->n_string[j] = 0;
  999.             }
  1000.             val = seq;
  1001.             break;
  1002.         default:
  1003.             xlbadtype(seq); break;
  1004.     }
  1005.         
  1006.             
  1007.     /* restore the stack */
  1008.     xlpop();
  1009.  
  1010.     /* return the updated sequence */
  1011.     return (val);
  1012. }
  1013.  
  1014. /* xdelif - built-in function 'delete-if' -- enhanced version */
  1015. LVAL xdelif()
  1016. {
  1017.     return (delif(TRUE,FALSE));
  1018. }
  1019.  
  1020. /* xdelifnot - built-in function 'delete-if-not' -- enhanced version */
  1021. LVAL xdelifnot()
  1022. {
  1023.     return (delif(FALSE,FALSE));
  1024. }
  1025.  
  1026. /* xdelete - built-in function 'delete' -- enhanced version */
  1027.  
  1028. LVAL xdelete()
  1029. {
  1030.     return (delif(TRUE,TRUE));
  1031. }
  1032.  
  1033. #ifdef ADDEDTAA
  1034. /* xcountif - built-in function 'count-if     TAA MOD addition */
  1035. LVAL xcountif()
  1036. {
  1037.     unsigned counter=0;
  1038.     unsigned i,l;
  1039.     unsigned start,end;
  1040.     LVAL seq, fcn;
  1041.  
  1042.     
  1043.     /* get the arguments */
  1044.     fcn = xlgetarg();
  1045.     seq = xlgetarg();
  1046. /*    xllastarg(); */
  1047.  
  1048.     if (seq == NIL) return (cvfixnum((FIXTYPE)0));
  1049.  
  1050.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  1051.  
  1052.     xlstkcheck(1);
  1053.     xlprotect(fcn);
  1054.  
  1055.     /* examine arg and count */
  1056.     switch (ntype(seq)) {
  1057.         case CONS:
  1058.             end -= start;
  1059.             for (; consp(seq) && start-- > 0; seq = cdr(seq));
  1060.             for (; consp(seq); seq = cdr(seq))
  1061.                 if (end-- > 0 && dotest1(car(seq),fcn)) counter++;
  1062.             break;
  1063.         case VECTOR:
  1064.             l = getlength(seq);
  1065.             if (end < l) l = end;
  1066.             for (i=start; i < l; i++)
  1067.                 if (dotest1(getelement(seq,i),fcn)) counter++;
  1068.             break;
  1069.         case STRING:
  1070.             l = getslength(seq)-1;
  1071.             if (end < l) l = end;
  1072.             for (i=start; i < l; i++)
  1073.                 if (dotest1(cvchar(getstringch(seq,i)),fcn)) counter++;
  1074.             break;
  1075.         default:
  1076.             xlbadtype(seq); break;
  1077.     }
  1078.  
  1079.     xlpop();
  1080.  
  1081.     return (cvfixnum((FIXTYPE)counter));
  1082. }
  1083.  
  1084. /* xfindif - built-in function 'find-if'    TAA MOD */
  1085. LVAL xfindif()
  1086. {
  1087.     LVAL seq, fcn, val;
  1088.     unsigned start,end;
  1089.     unsigned i,l;
  1090.     
  1091.     fcn = xlgetarg();
  1092.     seq = xlgetarg();
  1093. /*    xllastarg(); */
  1094.     
  1095.     if (seq == NIL) return NIL;
  1096.  
  1097.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  1098.  
  1099.     xlstkcheck(1);
  1100.     xlprotect(fcn);
  1101.  
  1102.     switch (ntype(seq)) {
  1103.         case CONS:
  1104.             end -= start;
  1105.             for (; consp(seq) && start-- > 0; seq = cdr(seq));
  1106.             for (; consp(seq); seq = cdr(seq)) {
  1107.                 if (end-- > 0 && dotest1(val=car(seq), fcn)) goto fin;
  1108.             }
  1109.             break;
  1110.         case VECTOR:
  1111.             l = getlength(seq);
  1112.             if (end < l) l = end;
  1113.             for (i=start; i < l; i++)
  1114.                 if (dotest1(val=getelement(seq,i),fcn)) goto fin;
  1115.             break;
  1116.         case STRING:
  1117.             l = getslength(seq)-1;
  1118.             if (end < l) l = end;
  1119.             for (i=start; i < l; i++)
  1120.                 if (dotest1(val=cvchar(getstringch(seq,i)),fcn)) goto fin;
  1121.             break;
  1122.         default:
  1123.             xlbadtype(seq); break;
  1124.     }
  1125.  
  1126.     val = NIL;    /* not found */
  1127.     
  1128. fin:
  1129.     xlpop();
  1130.     return (val);
  1131. }
  1132.  
  1133. /* xpositionif - built-in function 'position-if'    TAA MOD */
  1134. LVAL xpositionif()
  1135. {
  1136.     LVAL seq, fcn;
  1137.     unsigned start,end;
  1138.     unsigned count;
  1139.     unsigned i,l;
  1140.     
  1141.     fcn = xlgetarg();
  1142.     seq = xlgetarg();
  1143. /*    xllastarg(); */
  1144.     
  1145.     if (seq == NIL) return NIL;
  1146.  
  1147.     getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
  1148.  
  1149.     xlstkcheck(1);
  1150.     xlprotect(fcn);
  1151.  
  1152.     switch (ntype(seq)) {
  1153.         case CONS:
  1154.             end -= start;
  1155.             count = start;
  1156.             for (; consp(seq) && start-- > 0; seq = cdr(seq));
  1157.             for (; consp(seq); seq = cdr(seq)) {
  1158.                 if ((end-- > 0) && dotest1(car(seq), fcn)) goto fin;
  1159.                 count++;
  1160.             }
  1161.             break;
  1162.         case VECTOR:
  1163.             l = getlength(seq);
  1164.             if (end < l) l = end;
  1165.             for (i=start; i < l; i++)
  1166.                 if (dotest1(getelement(seq,i),fcn)) {
  1167.                     count = i;
  1168.                     goto fin;
  1169.                 }
  1170.             break;
  1171.         case STRING:
  1172.             l = getslength(seq)-1;
  1173.             if (end < l) l = end;
  1174.             for (i=start; i < l; i++)
  1175.                 if (dotest1(cvchar(getstringch(seq,i)),fcn)) {
  1176.                     count = i;
  1177.                     goto fin;
  1178.                 }
  1179.             break;
  1180.         default:
  1181.             xlbadtype(seq); break;
  1182.     }
  1183.  
  1184.     xlpop();    /* not found */
  1185.     return(NIL);
  1186.  
  1187. fin:            /* found */
  1188.     xlpop();
  1189.     return (cvfixnum((FIXTYPE)count));
  1190. }
  1191. #endif
  1192.  
  1193. /* xsearch -- search function */
  1194.  
  1195. LVAL xsearch()
  1196. {
  1197.     LVAL seq1, seq2, fcn, temp1, temp2;
  1198.     unsigned start1, start2, end1, end2, len1, len2;
  1199.     unsigned i,j;
  1200.     int tresult,typ1, typ2;
  1201.     
  1202.     /* get the sequences */
  1203.     seq1 = xlgetarg();    
  1204.     len1 = getlength(seq1);
  1205.     seq2 = xlgetarg();
  1206.     len2 = getlength(seq2);
  1207.  
  1208.     /* test/test-not args? */
  1209.     xltest(&fcn,&tresult);
  1210.  
  1211.     /* check for start/end keys */
  1212.     getseqbounds(&start1,&end1,len1,&k_1start,&k_1end);
  1213.     getseqbounds(&start2,&end2,len2,&k_2start,&k_2end);
  1214.     
  1215.     if (end2 - 1 - (end1 - start1) > len2) {
  1216.         end2 = len2 + 1 + (end1 - start1);
  1217.         if (end2 < start2) end2 = start2;
  1218.     }
  1219.     
  1220.     len1 = end1 - start1;    /* calc lengths of sequences to test */
  1221.  
  1222.     typ1 = ntype(seq1);
  1223.     typ2 = ntype(seq2);
  1224.     
  1225.     xlstkcheck(1);
  1226.     xlprotect(fcn);
  1227.  
  1228.     if (typ1 == CONS) {    /* skip leading section of sequence 1 if a cons */
  1229.         j = start1;
  1230.         while (j--) seq1 = cdr(seq1);
  1231.     }
  1232.  
  1233.     if (typ2 == CONS) {    /* second string is cons */
  1234.         i = start2;        /* skip leading section of string 2 */
  1235.         while (start2--) seq2 = cdr(seq2);
  1236.  
  1237.         for (;i<end2;i++) {
  1238.             temp2 = seq2;
  1239.             if (typ1 == CONS) {
  1240.                 temp1 = seq1;
  1241.                 for (j = start1; j < end1; j++) {
  1242.                     if (dotest2(car(temp1),car(temp2),fcn) != tresult)
  1243.                         goto next1;
  1244.                     temp1 = cdr(temp1);
  1245.                     temp2 = cdr(temp2);
  1246.                 }
  1247.             }
  1248.             else {
  1249.                 for (j = start1; j < end1; j++) {
  1250.                     if (dotest2(typ1 == VECTOR ? getelement(seq1,j) :
  1251.                         cvchar(getstringch(seq1,j)), car(temp2), fcn) != tresult)
  1252.                         goto next1;
  1253.                     temp2 = cdr(temp2);
  1254.                 }
  1255.             }
  1256.             xlpop();
  1257.             return cvfixnum(i);
  1258.             next1: /* continue */
  1259.             seq2 = cdr(seq2);
  1260.         }
  1261.     }
  1262.                 
  1263.     else for (i = start2; i < end2 ; i++) { /* second string is array/string */
  1264.         if (typ1 == CONS) { 
  1265.             temp1 = seq1;
  1266.             for (j = 0; j < len1; j++) {
  1267.                 if (dotest2(car(temp1), 
  1268.                             typ2 == VECTOR ? getelement(seq2,i+j) 
  1269.                                            : cvchar(getstringch(seq2,i+j)),
  1270.                             fcn) != tresult)
  1271.                     goto next2;
  1272.                 temp1 = cdr(temp1);
  1273.             }
  1274.         }
  1275.         else for (j=start1; j < end1; j++) {
  1276.             if (dotest2(typ1 == VECTOR ? getelement(seq1,j) : cvchar(getstringch(seq1,j)),
  1277.                 typ2 == VECTOR ? getelement(seq2,i+j-start1) : cvchar(getstringch(seq2,i+j-start1)), fcn) != tresult)
  1278.                     goto next2;
  1279.         }
  1280.         xlpop();
  1281.         return cvfixnum(i);
  1282.         next2:; /* continue */
  1283.     }
  1284.     
  1285.     xlpop();
  1286.     return (NIL);    /*no match*/
  1287.  
  1288. }
  1289.  
  1290.  
  1291. #endif
  1292.  
  1293.